perm filename INDATE.SAI[X,ALS] blob
sn#089974 filedate 1974-03-05 generic text, type T, neo UTF8
00010 ENTRY PREPARE;
00020 BEGIN
00030 DEFINE ⊂="COMMENT",CR="'15",LF="'12",CRLF="CR&LF",TB="'11";
00040 DEFINE ⊃=" "; ⊂ Used to delete output statements for PLOT;
00050 DEFINE $=" "; ⊂ Used to delete outstr's;
00060 DEFINE Z="10000%256";
00070 EXTERNAL REAL ARRAY A,C,D[0:512];
00080 ⊃ INTERNAL INTEGER ARRAY NEW[0:512];
00090 INTERNAL INTEGER ARRAY INNAME,INDATA[0:32];
00100 EXTERNAL INTEGER ARRAY FVAL[0:8];
00105 EXTERNAL INTEGER F1AS,F1S,F2S,F3S,F4S,F5S;
00107 EXTERNAL REAL CF1S;
00110 INTEGER I,J,K,P,POINTP,NX;
00120 ⊃ EXTERNAL INTEGER CHAN5;
00130 INTERNAL INTEGER INFLAG;
00140 INTEGER F1_LOW,F1_HI,F2_LOW,F2_HI,F3_LOW,F3_HI,F4_LOW,F4_HI,F5_LOW;
00150 INTEGER F5_HI,NP_LOW,NP_HI,NZ_LOW,NZ_HI,FP1_LO,FP1_H,FP2_LO,FP2_H;
00160 INTERNAL INTEGER F1A,F1,F2,F3,F4,F5,NP,NZ,FP1,FP2,A1A,A1,A2,A3,A4,A5;
00170 INTEGER FA,FB,FC,FD,FE;
00180 INTEGER M1,M2,M3,M4,M5;
00190
00200
00210
00220
00230 INTERNAL PROCEDURE DEFINES;
00240 BEGIN
00250 F1_LOW← 180 * 256%10000; F1_HI← 850 * 256%10000;
00260 F2_LOW← 700 * 256%10000; F2_HI← 2500 * 256%10000;
00270 F3_LOW← 1570 * 256%10000; F3_HI← 3400 * 256%10000;
00280 F4_LOW← 2500 * 256%10000; F4_HI← 4500 * 256%10000;
00290 F5_LOW← 3600 * 256%10000; F5_HI← 5400 * 256%10000;
00300
00310 M1← 320 * 256%10000;
00320 M2← 1350 * 256%10000;
00330 M3← 2800 * 256%10000;
00340 M4← 3400 * 256%10000;
00350 M5← 4500 * 256%10000;
00360
00370 FP1_LO← 1800 * 256%10000; FP1_H← 3200 * 256%10000;
00380 FP2_LO← 3200 * 256%10000; FP2_H← 5000 * 256%10000;
00390
00400
00410 NP_LOW← 800 * 256%10000; NP_HI← 1500 * 256%10000;
00420 NZ_LOW←NP-500* 256%10000; NZ_HI←NP+500* 256%10000;
00430 END;
00440
00450 INTERNAL PROCEDURE DATOUT;
00460 BEGIN
00470
00480 ⊃ ARRYOUT(CHAN5,NEW[0],512);
00490 ⊃ POINTP←POINT(9,NEW[1],-1);
00500 NX←0;
00510 END;
00520
00530
00540
00010 INTEGER PROCEDURE PEAK (INTEGER LOW,HIGH);
00020 BEGIN
00030 INTEGER I,J,K; REAL MAX,MIN;
00040
00050 MAX←-10000; K←LOW;
00060
00070 FOR I←LOW STEP 1 UNTIL HIGH DO
00080 IF C[I]>MAX THEN BEGIN MAX←C[I]; J←I; END;
00090
00100 IF J=LOW THEN BEGIN
00110 MAX←-10000; MIN←10000;
00120 FOR I←LOW STEP 1 UNTIL HIGH DO BEGIN
00130 IF C[I]>MIN THEN DONE;
00140 IF C[I]<MIN THEN BEGIN MIN←C[I]; K←I; END;
00150 END;
00160
00170 FOR I←K STEP 1 UNTIL HIGH DO
00180 IF C[I]>MAX THEN BEGIN MAX←C[I]; J←I; END;
00190 END;
00200
00210 IF J=HIGH THEN BEGIN
00220 MAX←-10000; MIN←10000;
00230 FOR I←HIGH STEP -1 UNTIL K DO BEGIN
00240 IF C[I]>MIN THEN DONE;
00250 IF C[I]<MIN THEN MIN←C[I];
00260 END;
00270
00280 FOR I←I STEP -1 UNTIL K DO
00290 IF C[I]>MAX THEN BEGIN MAX←C[I]; J←I; END;
00300 END;
00310
00320 IF J=LOW THEN J←0; ⊂ No proper peak found;
00330
00340 RETURN(J);
00350 END;
00360
00370 INTEGER PROCEDURE BAND(INTEGER F);
00380 BEGIN
00390 INTEGER I,J;
00400
00410 FOR I←F STEP 1 UNTIL 255 DO IF (C[I]+6)≤C[F] THEN DONE;
00420 ⊂ OUTSTR("F="&CVS(F)&TB&"I="&CVS(I)&TB);
00430
00440 FOR J←F STEP -1 UNTIL 0 DO IF (C[J]+6)≤C[F] THEN DONE;
00450 ⊂ OUTSTR("J="&CVS(J)&CRLF);
00460 IF (F-J)<(I-F) THEN RETURN(F-J) ELSE RETURN(I-F);
00470 END;
00480
00490 INTEGER PROCEDURE REMOVE(INTEGER F,LIMIT);
00500 BEGIN
00510 INTEGER I,J,K;
00520 REAL X,Y,MAX,MIN;
00530
00540 FOR I←F STEP 1 UNTIL LIMIT DO IF C[I]≤C[F]-6 THEN BEGIN J←I; DONE; END;
00550 FOR I←F STEP -1 UNTIL 0 DO IF C[I]≤C[F]-6 THEN BEGIN K←I; DONE; END;
00560 IF ABS(F-K)<ABS(J-F) THEN I←ABS(F-K) ELSE I←ABS(J-F);
00570 X←6.0; X←X/(I*I);
00580 MAX←-10000;
00590 ⊂ OUTSTR("I="&CVS(I)&" ");
00600
00610 FOR I←I+F STEP 1 UNTIL LIMIT DO
00620 IF (Y←(C[I]-C[F]+X*(I-F)*(I-F)))>MAX THEN BEGIN MAX←Y; J←I; END;
00630 IF J=LIMIT THEN J←0;
00640
00650 RETURN(J);
00660 END;
00670
00010 PROCEDURE FORMANT;
00020 BEGIN
00030
00040 REAL X,Y;
00050
00060 IF INFLAG=0 THEN BEGIN
00070 ⊃ POINTP←POINT(9,NEW[1],-1); NX←0;
00080
00090 INNAME[P]←CVASC("F1"); P←P+1;
00100 INNAME[P]←CVASC("F2"); P←P+1;
00110 INNAME[P]←CVASC("F3"); P←P+1;
00115 INNAME[P]←CVASC("F1A"); P←P+1;
00120 INNAME[P]←CVASC("F4"); P←P+1;
00130 INNAME[P]←CVASC("F5"); P←P+1;
00140
00150 INNAME[P]←CVASC("A1"); P←P+1;
00160 INNAME[P]←CVASC("A2"); P←P+1;
00170 INNAME[P]←CVASC("A3"); P←P+1;
00175 INNAME[P]←CVASC("A1A"); P←P+1;
00180 INNAME[P]←CVASC("A4"); P←P+1;
00190 INNAME[P]←CVASC("A5"); P←P+1;
00200
00210 INNAME[P]←CVASC("B1"); P←P+1;
00220 INNAME[P]←CVASC("B2"); P←P+1;
00230 INNAME[P]←CVASC("B3"); P←P+1;
00235 INNAME[P]←CVASC("B1A"); P←P+1;
00240 INNAME[P]←CVASC("B4"); P←P+1;
00250 INNAME[P]←CVASC("B5"); P←P+1;
00260
00270 END ELSE BEGIN
00280 $ OUTSTR(CRLF&"⊗ ");
00290
00310 F1←PEAK(F1_LOW,F1_HI);
00315 F1A←PEAK(0,F1);
00320 F2←PEAK(F2_LOW,F2_HI);
00321
00323 $ IF C[F1A]>C[FA] THEN OUTSTR("Voice-bar at "&CVS(F1A*Z)&",F1="&CVS(F1*Z)&",");
00330 IF (C[F1]<C[F1A])∧(C[F1]≤C[F2]) THEN BEGIN
00335 $ outstr("Remove,");
00340 IF F2<F1_HI THEN FA←REMOVE(F1A,F2) ELSE FA←REMOVE(F1A,F1_HI);
00345 $ outstr("FA="&CVS(FA*Z)&",");
00350 IF (C[FA]>C[F1])∧(FA≥F1_LOW-1) THEN BEGIN
00360 $ OUTSTR("Remove,old F1="&CVS(F1*Z)&",New="&CVS(FA*Z)&TB);
00370 F1←FA; END;
00380 END;
00385
00390 IF (F1+3>F1S)∧(F1+4<F2_LOW) THEN F2←PEAK(F2_LOW,F2_HI)
00400 ELSE BEGIN
00410 IF F1S>F2_LOW THEN F2←PEAK(F1S+1,F2_HI)
00420 ELSE F2←PEAK(F2_LOW,F2_HI); END;
00430
00440 F3←PEAK(F3_LOW,F3_HI);
00450 F4←PEAK(F4_LOW,F4_HI);
00460 F5←PEAK(F5_LOW,F5_HI);
00470
00480 IF F1=F2 THEN BEGIN
00490 $ OUTSTR("F1=F2="&CVS(F1*10000%256));
00500 FA←PEAK(F1_LOW,F1);
00510 IF FA=0 THEN X←0 ELSE X←C[FA];
00515 IF FA=F1 THEN X←0;
00520 FB←PEAK(F2,F2_HI);
00530 IF FB=0 THEN Y←0 ELSE Y←C[FB];
00540 IF (X>Y)∧((X+6)>C[F1]) THEN F1←FA ELSE F2←FB;
00550 $ OUTSTR("FA="&CVS(FA*Z)&","&CVF(X)&"FB="&CVS(FB*Z)&","&CVF(Y)&TB);
00560 END;
00570
00580 IF F2=0 THEN BEGIN
00590 F2←REMOVE(F1,F2_HI);
00600 $ OUTSTR("REMOVE ");
00610 END;
00620 IF F2<F2_LOW THEN F2←F2S;
00630
00640 IF (F2+4) < F3_LOW THEN F3←PEAK(F3_LOW-2,F3_HI)
00650 ELSE F3←PEAK(F3_LOW,F3_HI);
00660
00670 IF F2=F3 THEN BEGIN
00680 $ OUTSTR("F2=F3="&CVS(F3*10000%256));
00685 IF CF1S>C[F1]-6 THEN FC←PEAK((F3+F3S)%2,(F3_HI+F3S+1)%2) ELSE
00690 FC←PEAK(F3,F3_HI);
00700 IF (FC=0)∨(FC=F2) THEN Y←0 ELSE Y←C[FC];
00710 IF F1>F2_LOW THEN BEGIN
00715 IF CF1S>C[F1]-6 THEN FB←PEAK((F1+F2S)%2,(F2+F2S+1)%2) ELSE FB←PEAK(F1,F2); END
00717 ELSE BEGIN
00718 IF CF1S>C[F1]-6 THEN FB←PEAK((F2_LOW+F2S)%2,(F2+F2S+1)%2) ELSE
00719 FB←PEAK(F2_LOW,F2); END;
00720 IF (FB=0)∨(FB=F2) THEN X←0 ELSE X←C[FB];
00725 IF (X=0)∧(Y=0) THEN BEGIN F2←F2S; F3←F3S; END ELSE
00730 IF Y≥X THEN F3←FC ELSE F2←FB;
00740 $ OUTSTR("FB="&CVS(FB*Z)&","&CVS(X)&"FC="&CVS(FC*Z)&","&CVF(Y)&TB);
00750 END;
00760
00770 IF ((C[F2]+24)<C[F1])∧(F1>F2_LOW) THEN BEGIN
00780 IF F3>F2_HI THEN FB←REMOVE(F1,F2) ELSE FB←REMOVE(F1,F2_HI);
00790 IF (FB=0)∨(FB=F2) THEN X←0 ELSE X←C[FB];
00800 IF X>C[F2] THEN F2←FB;
00810 END;
00820
00830 IF F3=F4 THEN BEGIN
00840 $ OUTSTR("F3=F4="&CVS(F4*10000%256));
00850 FD←PEAK(F4,F4_HI);
00860 IF (FD=0)∨(FD=F3) THEN Y←0 ELSE Y←C[FD];
00870 IF F2>F3_LOW THEN BEGIN
00871 IF CF1S>C[F1]-6 THEN FC←PEAK((F2+F3S)%2,(F3+F3S+1)%2) ELSE FC←PEAK(F2,F3); END
00872 ELSE BEGIN
00873 IF CF1S>C[F1]-6 THEN FC←PEAK((F3_LOW+F3S)%2,(F3+F3S+1)%2) ELSE
00874 FC←PEAK(F3_LOW,F3); END;
00880 IF (FC=0)∨(FC=F3) THEN X←0 ELSE X←C[FC];
00885 IF (X=0)∧(Y=0) THEN BEGIN F3←F3S; F4←F4S; END ELSE
00890 IF Y+3≥X THEN F4←FD ELSE F3←FC;
00900 $ OUTSTR("FC="&CVS(FC*Z)&","&CVS(X)&"FD="&CVS(FD*Z)&","&CVF(Y)&TB);
00910 END;
00920
00930 IF F4=F5 THEN BEGIN
00940 $ OUTSTR("F4=F5="&CVS(F5*10000%256));
00950 FE←PEAK(F5,F5_HI);
00960 IF (FE=0)∨(FE=F5) THEN Y←0 ELSE Y←C[FE];
00970 IF F3>F4_LOW THEN BEGIN
00971 IF CF1S>C[F1]-6 THEN FD←PEAK((F3+F4S)%2,(F4+F4S+1)%2) ELSE FD←PEAK(F3,F4); END
00972 ELSE BEGIN
00973 IF CF1S>C[F1]-6 THEN FD←PEAK((F4_LOW+F4S)%2,(F4+F4S+1)%2) ELSE
00974 FD←PEAK(F4_LOW,F4); END;
00980 IF (FD=0)∨(FD=F4) THEN X←0 ELSE X←C[FD];
00985 IF (X=0)∧(Y=0) THEN BEGIN F4←F4S; F5←F5S; END ELSE
00990 IF Y+3≥X THEN F5←FE ELSE F4←FD;
01000 $ OUTSTR("FD="&CVS(FD*Z)&","&CVS(X)&"FE="&CVS(FE*Z)&","&CVF(Y)&TB);
01010 END;
01020
01025 IF F1=F1A THEN F1A←PEAK(0,F1); IF F1=F1A THEN F1A←0;
01030 $ OUTSTR(CRLF&TB&CVS(F1A*Z)&"-"&CVS(F1*Z)&","&CVS(F2*Z)&","&CVS(F3*Z)&","&CVS(F4*Z)
01040 &","&CVS(F5*Z)&CRLF);
01050
01060 INDATA[P]←F1S←F1; P←P+1;
01070 INDATA[P]←F2S←F2; P←P+1;
01080 INDATA[P]←F3S←F3; P←P+1;
01085 INDATA[P]←F1AS←F1A; P←P+1;
01090 INDATA[P]←F4S←F4; P←P+1;
01100 INDATA[P]←F5S←F5; P←P+1;
01110 INDATA[P]←CF1S←C[F1]; P←P+1;
01120 INDATA[P]←C[F2]; P←P+1;
01130 INDATA[P]←C[F3]; P←P+1;
01135 INDATA[P]←C[F1A]; P←P+1;
01140 INDATA[P]←C[F4]; P←P+1;
01150 INDATA[P]←C[F5]; P←P+1;
01160
01170 INDATA[P]←BAND(F1)*10000%256; P←P+1;
01180 INDATA[P]←BAND(F2)*10000%256; P←P+1;
01190 INDATA[P]←BAND(F3)*10000%256; P←P+1;
01192 INDATA[P]←BAND(F1A)*10000%256; P←P+1;
01195 INDATA[P]←BAND(F1A)*10000%256; P←P+1;
01200 INDATA[P]←BAND(F4)*10000%256; P←P+1;
01210 INDATA[P]←BAND(F5)*10000%256; P←P+1;
01220 END;
01230 END;
01240
00010 INTERNAL PROCEDURE PREPARE;
00020 BEGIN
00030
00040 P←0;
00050
00060 FORMANT;
00070
00080
00090 ⊃ IF INFLAG≠0 THEN BEGIN
00100 ⊃ NEW[NX]←FVAL[4];
00110 ⊃ FOR I←0 STEP 1 UNTIL 27 DO IDPB(INDATA[I],POINTP);
00120 ⊃ FOR I←1 STEP 1 UNTIL 4 DO IBP(POINTP);
00130 ⊃ NX←NX+8;
00140 ⊃ IF NX≥512 THEN DATOUT;
00150 ⊃ END;
00160
00170 END;
00180
00190 END;
00200